perm filename MARKZ.F4[NEW,LCS]2 blob sn#383518 filedate 1978-09-26 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C**** MARKZ -- XREAD (FOR MARKZ,SLURZ) -- ZNOTE -- MARKS
C00015 ENDMK
C⊗;
C**** MARKZ -- XREAD (FOR MARKZ,SLURZ) -- ZNOTE -- MARKS

	SUBROUTINE MARKZ
	COMMON /XRN/RN(1)
	1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
	1 NOSET,STEM,STUP,NTC,PS2,RAM,RDD,IT,POS /ALF/INP(72),ML
	1 /LIMIT/LIMIT,ITEM,LL,IS,IX 
	1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
	1 /SCX/JALPHA(7),ISTAR,JAL(22),JX,U,JZ,IRHY,JD,KA,KB,IZ
	1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
	1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA

	INVT=-1
	JNTC=NTC-1
C  JNTC=NUM OF NTS NOW
	JREP=-1
C  JREP IS FOR REPEAT FEATURE IN 'MARKS'
25	CALL XREAD
505	L=0
	K=0
	POS=-10.
5032	IF(N.LE.JNTC)GO TO 5030
	N=JNTC  
C TRAPS ERROR OF TRYING TO PUT MARK ON NON-EXISTENT NOTE.
	VX(J)=N
C VX(J)=N IS NEEDED AT LABEL 130  
5030	L=L+1
502	K=K+1
	IF(R(1,K).NE.1.)GO TO 502
C  IS IT A NOTE?
	P=R(3,K)
	IF(P.EQ.POS)GO TO 502
C  SKIPS DBLSTPS
	POS=P
506	IF(L.LT.N)GO TO 5030
30	IF(JREP)CALL MARKS(RA)
	RB=0
	J=J+1
	IF(RA.GE.30.AND.RA.LE.35)VX(J+1)=0
C THIS  ↑↑↑↑ CATCHES FINGERING NUM.(0-5)  IT WAS READ IN MARKS.
	IF(RA.EQ.99)RA=VX(J)
C  IF STEM IS DOWN OR THERE ARE NOTES BELOW(DBL STP), POSITION
C    OF ACCENT WILL BE INVERTED.
130	IF(RA.LT.37)GO TO 304
C  37=RIT.
	C=POSIT(VX(J-1))

	IF(RA.LE.60.OR.RA.GT.63)GO TO 308
C NEXT FOR TREMOLO: TM, TME, TMS, =32ND, 8TH, 16TH
	NN=11
	A=8
C A IS WDCNT-2
	B=6
C CODE NUM. IS IN B
CXCX	C=C+1.5
C FIND POSITION OF THIS NOTE
	BB=R(4,K)
C  BB=HEIGHT
	RC=AMOD(R(7,K),10.0)
C LOOK FOR TAILS
	X=0
	IF(RA.EQ.61)X=1
C RA=61= 8TH NOTE BEAM
	AA=R(8,K)
C TREM. POS. WILL DEPEND ON NOTE POS. AND STEM LENGTH
	IF(AA.NE.0)GO TO 2309
	AA=1-X
	R(8,K)=1.2-X
2309	AA=AA-1  
C  AA = AMOUNT TO BE ADDED OR SUBTRACTED  WITH HEIGHT OF NOTE
	IF(R(5,K).GE.20)GO TO 1309
C CHECK ON STEM DIRECTION
	X=-(RA-50)
C MAKES -11, -12, -13, ETC.
	IF(RC.NE.0)BB=BB-2
	GO TO 309
1309	X=-(RA-40)
C MAKES -21, -22, ETC.
	AA=-AA
	IF(RC.NE.0)BB=BB+2
309	BB=BB+AA
C OK FOR 16TH AND 32ND - BUT 8TH NEEDS MORE WORK******
	RC=0
	RN(IS+9)=0   
	RN(IS+10)=0
C ABOVE IS TO LEAVE ROOM FOR CHANGE OF TREM TO BE PARALLEL TO OTHER BM.
	GO TO 305

308	IF(RA.LT.100)C=C-1.5
C  '-1.5' PUSHES IT TO LEFT. MAYBE CHANGE ORIGINAL POSITIONS??
	NN=6
	RC=RA
	BB=-6
	A=3
	B=3
	IF(XNOTE(K).LT.3)BB=XNOTE(K)-7.5
C LOWERS ITEM IF NOTE BELOW STAFF.  BUT IS 'K' ALWAYS OK HERE??????
	IF(RA.LT.99)GO TO 305
C NEXT FOR CRESC. & DECRSC. LINES<,>. TYPE /NT1 C+ NT2/ OR /N1.d  C- N2.d/
C ALSO FOR "8va ----" /NT1 O NT2/
	NN=8
	BB=BB+2.5
	A=5
	B=4
	RB=50
	IF(RA.NE.208)GO TO 306
	RB=0
	B=7
	BB=15
C  LATER ADD CHECK FOR HEIGHT OF NOTES UNDER 8va.
306	X=RA-200
C  MAKES ZERO OR -1 OR 8 IN P7
	RC=RB
C  ADDS A NEW ITEM.  MP, PP, CRESC., ETC. --CODE 3
305	CALL RNX(A,B,STAFF,C,BB,RC,0,X,0)
C RNX FILLS PARAMS 0→8
	IS=IS+NN
	IF(B.EQ.3.OR.B.EQ.6)GO TO 230
C B=6=TREM. NN=6=WORDS OR LTRS. UNDER STAFF.
	J=J+1
	RC=POSIT(VX(J))
	IF(RB.EQ.0)RC=RC+3
C RB=0= 8va
	RN(IS-2)=RC
C  THIS IS P6 (POS2 FOR CRESC. LINES)
514	J=J+1
	A=VX(J)
	N=A
C  SO ITEMS NEED NOT BE IN RIGHT ORDER.
	IF(MOD(N,100).GT.IRHY)A=0
	IF(A.NE.0)GO TO 505
CC***USE NO NUMBS IN COMMENTS IN MODE 3-5******	IF(VX(J+2).EQ.0)GO TO 614
	IF(J.LT.50)GO TO 514
C  SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
614	IF(INP(72).NE.ISTAR)GO TO  552

714	IF(INVT)RETURN
	INVT=IS
 	CALL NEWR
	IS=INVT
	RETURN
552	CALL BMREAD
C  TO READ MORE THAN 2 LINES.
	GO TO 25


304	RB=R(2,K)
	IF(RA.EQ.6)RA=26.
	A=RA
	IF(RB.EQ.0)GO TO 301
	IF(RB.GE.10)GO TO 303
	A=A*100
	GO TO 301
303	RB=RB*100
301	R(2,K)=RB+A
C  P11 INFO(MARKS) IS TEMPORARILY STORED IN P2 (STAFF# IS IN STAFF)
230	A=VX(J)
	JREP=-1
	IF(A.EQ.0)GO TO 514
C NEXT FOR STRING OF SAME MARK ( /3 12 S/ )
	IF(A.GT.JNTC)A=JNTC
C WON'T PUT MARK BEYOND LAST NOTE
	JREP=0
	J=J-1
	VX(J)=VX(J)+1
	IF(VX(J).GE.A)VX(J+1)=0
	J=J-1
	GO TO 514
C   USES 4-7,9,11-13 FOR ACC. > FERM. DOT - DNBOW UPBOW HARM.
C  NOTE#,ACCENT#/N,A/N,A*
	END


	SUBROUTINE XREAD
	COMMON /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72)
	1 /SCX/JALPHA(7),ISTAR,JAL(22),JX,U,JZ,IRHY,JD,KA,KB,IZ
	1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
	1 ,JXX,ISEMI,IQT,VX(50),IAMP,K
	DO 1500 K=1,72
	IF(INP(K).EQ.ISTAR)GO TO 15  
1500	IF(INP(K).EQ.ISEMI)GO TO 500
15	INP(72)=ISTAR
C ABOVE FOR 2ND LNE OF INPUT. IF LNS ENDS WITHOUT * OR ;, IT PUTS IN *
C  *******  1ST MAIN LOOP *********
500	REREAD F78F,VX
	J=0
	IF(IREAD.EQ.-1)J=1
C  SKIPS LINE #S IN SOS FILES. (=-2 IS FOR ET FILES.)
	J=J+1
	N=VX(J)
	END
 
	FUNCTION ZNOTE(K)
C ADJUSTS HEIGHT IN RE. TO STAFF ABOVE OR BELOW AND SPECIFIED STEM DIR.
	COMMON /SCX/JALPHA(30),X /RINP/R(10,85)
	1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM
	ZNOTE=XNOTE(K)
	IF(JSTEM.GT.K)RETURN
	L=R(10,K)
	IF(L.EQ.0)RETURN
	M=X/10.
	IF(M.EQ.0)RETURN
	IF(M.EQ.L)RETURN
	M=R(5,K)/10.
C ASSUMES SPECIFIED STEM DIR. IS CORRECT
	A=0
	IF(L.EQ.1)GO TO 1
	IF(M.EQ.2)A=-14.
	GO TO 2
1	IF(M.EQ.1)A=14.
2	ZNOTE=ZNOTE+A
	END

	SUBROUTINE MARKS(RA)
	COMMON/ALF/INP(72),ML  /JCHAR/IXX,ISEMX,IBLA
	1 /MKS/MKS(14) /MKX/KSLA,ISEMI,NONO(7),MINUS,ISTAR
	1 /A2Z/A1(4),LEE,A2(6),LEL,LMM,LNN,A3(11),LZZ
	1 /SCX/ICOM,MINU,IDOT,IEQ,LPRN,IRPRN,IPLUS
	1 /SC/J,NO(15),VX(50)
	EQUIVALENCE (MF,MKS(3)),(MH,MKS(9)),(MP,MKS(11)),(MM,MKS(5))
	1,(MC,MKS(12)),(MR,MKS(13)),(MI,MKS(10)),(MS,MKS(4))
	1,(MO,MKS(14)),(MW,MKS(1))
	RA=99
	DO 16 JM=1,72
16	IF(INP(JM))GO TO 17
C  DIDN'T FIND  MORE LETTERS
	RETURN
17	N=INP(JM)
	ML=INP(JM+1)
	M=INP(JM+2)
	DO 1 K=1,14
1	IF(N.EQ.MKS(K))GO TO 2
C  DID NOT FIND A LETTER
	RETURN
C 4=W(EDGE),5=A(CCENT),26=FE(RMATA),7=S(TACCATO),9=T(ENUTO)
C 11=D(OWNBOW), 12=U(PBOW),13=H(ARMONIC),14=PL(US),15=TH(ESIS)
C 16=AR(SIS),17=MO(RDANT)
C 18=I(NVRTD MORD), ---,20=TR(ILL), 21=TRF(LAT), 22=TRS(HARP)
C 23=TRN(ATURAL),  >39=PPP, PP, CRESC., ETC.
C 25=HW (HEAVY WEDGE), 80=ACC(EL.)  FICTA:5=FLAT, 2=#, 3=NAT.
C 27=TS(TEN.+STAC.)   28=WS(WEDGE+STAC.)  29=AS(ACCENT+STACCATO)
2	GO TO(220,10,12,120,4,11,15,15,15,21,12,80,81,87),K
12	IF(ML.EQ.LEL)GO TO 320
C  ↑↑↑ PLUS
	IF(N.EQ.MF)GO TO 121
	RA=42
	IF(ML.NE.MP)GO TO 18
	RA=41
	IF(M.EQ.MP)RA=40
C  FOR P, PP, PPP  -- 42, 41, 40
	GO TO 18
220	IF(ML.EQ.MS)K=25  
C 'WS' = WEDGE+STACCATO =28
	GO TO 320
15	IF(ML.EQ.MI)GO TO 82
	K=K+1
	IF(ML.EQ.MW)K=22
C 'HW' MAKES 25  (EVENTUALLY MAKES CLEF# 44)
120	IF(ML.EQ.MF)GO TO 88
320	K=K+3
8	RA=K
C  YOU CAN TYPE # OR NAME OF MARK
18	DO 6 JM=1,72
	N=INP(JM)
	INP(JM)=IBLA
C  BLANKS OUT USED LETTERS
	IF(N.EQ.KSLA)RETURN
	IF(N.EQ.ISTAR)RETURN
6	IF(N.EQ.ISEMI)RETURN
4	IF(ML.EQ.MO)GO TO 20
	RA=43
	IF(ML.EQ.MF)RA=50
C  ↑↑↑↑↑ MP, MF
	GO TO 18
121	IF(ML.EQ.LEE)GO TO 320
C  ↑↑↑  FERMATA
	RA=51
	IF(ML.EQ.MF)RA=52
	IF(ML.EQ.MP)RA=54
	IF(M.EQ.MF)RA=53
C  F, FF, FFF, FP  -- 51, 52, 53, 54  --- SF=45, SFZ=92
	IF(ML.NE.MI)GO TO 22
C TYPE FIF, FIS, FIN FOR FICTA flat, sharp, natural
	RA=1
	IF(M.EQ.MS)RA=2
	IF(M.EQ.LNN)RA=3
	GO TO 18
22	M=NALF(ML)
	IF(M)GO TO 18
	IF(M.LE.5)RA=30+M
C  TYPE /2 F0/6 F5/ FOR FINGERING NUMS. 0-5
	GO TO 18
88	RA=45
C  FOR SF AND SFZ
	IF(INP(JM+2).EQ.LZZ)RA=92
	GO TO 18
10	IF(ML.EQ.MC)GO TO 84
C  'AC'=ACCEL.
	IF(ML.EQ.MR)K=13
C  'AR' FOR ARSIS
	IF(ML.EQ.MS)K=26
C 'AS'=ACCENT-STACCATO COMBO (=29)
	GO TO 320
11	IF(ML.EQ.MH)K=12
C THESIS
	IF(ML.NE.MM)GO TO 110
	K=60
	IF(M.EQ.LEE)K=58
	IF(M.EQ.MS)K=59
C TM=TREMOLO,3 BEAMS=63 AT LABEL 8
C TME, TMS: 61=1 BEAM, 62=2 BEAMS
110	IF(ML.NE.MR)GO TO 111
	K=17
C TR(ILL)=20 TRF(LAT)=21 TRS(HARP)=22 TRN(ATRL)=23
	IF(M.EQ.MF)K=18
	IF(M.EQ.MS)K=19
	IF(M.EQ.LNN)K=20
	GO TO 320
111	IF(ML.EQ.MS)K=24
C TS=TEN.+STAC.=27
	GO TO 320
20	K=17
	GO TO 8
21	K=18
	GO TO 8
CC80	IF(ML.EQ.IPLUS)GO TO 85
CC	IF(ML.EQ.MINUS)GO TO 86
C  FOR /N1 C+ N2/ ETC. -- CRESC. AND DECRESC. LINES.
C '+' IS OPTIONAL.   2ND NUM. MEANS NOT 'CRESC.'
80	IF(ML.EQ.MINUS)GO TO 86
CX	IF(ML.NE.MR)GO TO 85
	IF(VX(J+2).NE.0)GO TO 85
	RA=70
C  'CR'='CRESC.'
	GO TO 18
85	RA=200
	GO TO 18
86	RA=199
	GO TO 18
87	RA=208
	GO TO 18
C  ↑↑↑ FOR /N1 OT N2/  8va
81	RA=37
C  RIT.
	GO TO 18
82	RA=82
C   DIM.
	GO TO 18
84	RA=80
C  ACCEL.
	GO TO 18
	END